perm filename MACROS.LSP[PAR,ADA] blob
sn#516729 filedate 1980-07-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00018 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 KWOTE
C00005 00003 DEFMAC (define macro) and DEFSMAC (define simple macro) are like defun,
C00009 00004 defsmac, defmac (cont)
C00011 00005 SHELL, HUNKSHELL
C00016 00006 shell, hunkshell (cont)
C00019 00007 shell, hunkshell (cont)
C00023 00008 shell, hunkshell (cont)
C00027 00009 listshell is like shell except it stores its fields in a list.
C00033 00010 Makenumber*
C00037 00011 caddddr, ...
C00040 00012 subrcallmacro, subrcallfun, subrcallfunr (see also defunl)
C00043 00013 defunl
C00046 00014 defuna
C00049 00015 miscellaneous: mapcone, mapone, mapctwo, tab, princ-tab, princ-terpri
C00052 00016 RESCAN, RESCANCOMMAND
C00056 00017 RESCAN2 rescans the buffer, flushes through till gets a ""
C00058 00018 Returns information on terminal attched to the job.
C00060 ENDMK
C⊗;
;;; KWOTE
;;; from cgn.
;;; (kwote f), for s-expression f, is similar to (quote f), but if a list
;;; of the form (! x) appears somewhere in f, then x is evaluated and the
;;; result replaces (! x) in the s-expression returned by kwote. For example,
;;; (kwote (g (h b) (f (! (+ 1 2))))) will evaluate to (g (h b) (f 3)). Kwote
;;; is a not a fexpr but a macro; the expansion for the example above is
;;; (list 'g '(h b) (list 'f (+ 1 2))). Consing is only done when necessary;
;;; '(h b) can be used instead of (list 'h 'b) because there are no
;;; sub-expressions to evaluate.
;;;
;;; If "!" appears but is not the first argument of a list, then it is
;;; ignored.
;;;
;;; The argument to kwote must be a well-formed list; (kwote (a . b)) bombs.
(declare (mapex t) (macros t))
(defun kwote macro (app) (kwote1 (cadr app)))
(defun kwote1 (x)
(cond ((atom x) (list 'quote x))
((eq (car x) '!) (cadr x))
((kwote2 (mapcar 'kwote1 x)))))
(defun kwote2 (l)
(prog (xl)
(setq xl l)
a (or xl (return (list 'quote (mapcar 'cadr l))))
(or (atom (car xl)) (and (eq (caar xl) 'quote)
(progn (setq xl (cdr xl)) (go a))))
(return (cons 'list l))))
;;; DEFMAC (define macro) and DEFSMAC (define simple macro) are like defun,
;;; but they define the function as a macro instead of as an expr. They are
;;; less powerful then defining a macro directly (for example, they cannot be
;;; used to define macros with arbitrarily many arguments) but are easier to
;;; use. For example,
;;;
;;; (DEFSMAC F (X Y) (FOO (BAR X) (BAR Y)))
;;;
;;; causes F to be defined as a macro in such a way that every call (F e1 e2)
;;; will expand to (FOO (BAR e1) (BAR e2)) before it is evaluated.
;;;
;;; DEFSMAC should not be used if the arguments to the macro appear more than
;;; once in the body, or if the order of evaluation of the arguments and the
;;; body is important. For example,
;;;
;;; (DEFSMAC ABS (X) (COND ((> X 0) X) ((-X))))
;;;
;;; would give an undesirable expansion in a call like (ABS (SETQ X (1+ X))).
;;; (The expansion would increment X twice and return the wrong answer.)
;;;
;;; In these situations, DEFMAC should be used instead of DEFSMAC. If a macro
;;; is defined by DEFMAC, calls to it expand to a block which evaluates the
;;; arguments in the macro call, lambda-binds them to generated symbols, and
;;; evaluates and returns the macro body. For example, after making the
;;; definition:
;;;
;;; (DEFMAC ABS (X) (COND ((> X 0) X) ((-X))))
;;;
;;; the call (ABS (FOO 1)) would expand to something equivalent to
;;;
;;; ((LAMBDA (X) (COND ((> X 0) X) ((- X)))) (FOO 1))
;;;
;;; From this the compiler will produce in-line code to evaluate (FOO X) and
;;; take the absolute value of the result.
;;;
;;; The bodies of the arguments to DEFMAC and DEFSMAC can be implicit PROGNs.
;;;
;;; DEFSMAC and DEFMAC are macros themselves, not fexprs. This means that
;;; if they are called in a file which is being compiled, they will define
;;; the macro at compile time, and no code will be generated. This is almost
;;; always what you want, but you can do a (DECLARE (MACROS T)) in the
;;; file somewhere if you want the macros defined at run-time, too.
;;; defsmac, defmac (cont)
(defun defsmac macro (args)
(defsmac1 (cadr args) (caddr args) (cdddr args)))
(defun defmac macro (args)
(defmac1 (cadr args) (caddr args) (cdddr args)))
(defun defsmac1 (name formals body)
(kwote (defun (! name) macro (app)
(! (defsmac2 formals
(cond ((cdr body) (cons 'progn body))
(t (car body))))))))
(defun defsmac2 (formals body)
(kwote (sublis (! (defsmac3 formals 1)) (quote (! body)))))
(defun defsmac3 (formals n)
(cond ((null formals) nil)
((kwote (cons (cons (quote (! (car formals))) (car (! (defsmac4 n))))
(! (defsmac3 (cdr formals) (1+ n))))))))
(defun defsmac4 (n) (cond ((= n 0) 'app) ((list 'cdr (defsmac4 (1- n))))))
(defun defmac1 (name formals body)
(kwote (defun (! name) macro (app)
(list 'do (! (defmac2 formals 1)) nil (quote (! (defmac3 body)))))))
(defun defmac2 (formals n)
(cond ((null formals) nil)
(t (kwote (cons (list (quote (! (car formals))) (car (! (defsmac4 n))))
(! (defmac2 (cdr formals) (1+ n))))))))
(defun defmac3 (body)
(cond ((null (cdr body)) (cons 'return body))
(t (cons (car body) (defmac3 (cdr body))))))
;;; SHELL, HUNKSHELL
;;; SHELL and HUNKSHELL semulate record structures using list
;;; structure (in the first case) and hunks (in the second).
;;;
;;; For example a node of a sparse matrix of rational numbers might
;;; contain fields for a numerator, a denominator, fields for its row
;;; and column, and links to the nodes above and to the left of it.
;;; We could use the call
;;;
;;; (SHELL MATRIX-NODE NUM DEN ROW COL UP LEFT)
;;;
;;; to "define a new type" MATRIX-NODE with six components named NUM, DEN,
;;; ROW, COL, UP, and LEFT. (Of course no new data type is actually added
;;; to LISP.) The effect of the call to SHELL is to define thirteen macros,
;;; one for creating matrix-nodes, and two for accessing and updating each of
;;; the six fields. The creation macro is called ALLOC-MATRIX-NODE; a call
;;; to it evalutes to (CONS (CONS NIL NIL) (CONS (CONS NIL NIL) (CONS NIL NIL))),
;;; that is, to a sequence of cons which build a binary tree with six leaves.
;;; (The binary tree is constructed so as to minimize its maximum depth.)
;;; In general, the name of the allocation macro is always "ALLOC-"
;;; concatenated with the first argument to SHELL. For each field,
;;; its corresponding access macro is just the field name; for instance,
;;; (NUM x) accesses the NUM field of x. For each field, the update macro
;;; is X concatenated with the field name; thus (XNUM x y) would update
;;; the NUM field of x to y. (In particular, for the above shell, (NUM x)
;;; expands to (CADDR x) and (XNUM MNODE y) expands to (RPLACA (CDDR x) y).
;;;
;;; (Warning -- do not use the returned results of the update functions,
;;; since they depend on the structure of the binary tree allocated.)
;;;
;;; The expansion of SHELL is slightly different in the compiler and interpreter.
;;; In the interpreter, (SHELL ...) expands to a PROGN containing all the required
;;; macro definitions. In the compiler, this PROGN is put into a DECLARE, so that
;;; the calls to SHELL above define macros in the compilation enviornment. If
;;; you want the macros defined at run time, too, (declare (macros t)).
;;;
;;; The macro HUNKSHELL is identical to SHELL except that hunks are used
;;; for the records instead of list structure. Hunks use contiguous storage;
;;; thus a shell with 8 fields requires 14 halfwords per record (the binary
;;; tree needs 7 conses to construct it), while a hunkshell requires only 8
;;; halfwords. Since fields in hunks are directly accessible while fields
;;; in shells may have to do some indirect pointing down the binary tree first,
;;; code using hunkshells will always use less storage and may be faster.
;;; As of this writing however (Nov. 26, 1978), the maclsp compiler does not
;;; open code RPLACX which is a significant drawback on speed.
;;; As of September 1979, some of hunk code is better.
;;; shell, hunkshell (cont)
(declare (special shelllen))
;;; shelllen is a local special. The code should be fixed to eliminate it.
(defun shell macro (app)
(setq app (shell2* (cdr app)))
(cond ((memq 'ncomplr (status feature)) (eval app)))
app)
;;; shell2* returns a progn which contains all the macro definitions.
;;; the memq returns something non-nil iff we are in the compiler, in
;;; which case we want to get the macros defined immediatly, so we
;;; eval the progn. then the progn is returned as the expansion of
;;; the macro, so that in the interpreter it will get evalled, too;
;;; and in the compiler the macros will be sent to the target file
;;; if (macros t) is on.
(defun hunkshell macro (app)
(setq app (hunkshell2* (cdr app)))
(cond ((memq 'ncomplr (status feature)) (eval app)))
app)
(defun shell2* (l)
(prog (shelllen)
(setq shelllen (length (cdr l)))
(return (cons 'progn
(cons (define-alloc* (car l))
(append (define-accesses* (cdr l)
1)
(define-updates* (cdr l)
1)))))))
;;; shelllen will be used as a global variable by the functions whose
;;; names begin define. it is the number of components of the structure.
;;; concat concatenates its two atomic arguments into a single atom.
(defun concat* (a1 a2) (implode (nconc (explode a1) (explode a2))))
;;; example of function below: define-alloc('node) would return
;;; (defun alloc-node macro (ap) (quote (cons (cons nil nil) nil)))
;;; if shelllen were 3, since consup(3) is (cons (cons nil nil) nil)
(defun define-alloc* (name)
(list 'defun
(concat* 'alloc- name)
'macro
'(app)
(list 'quote (consup* shelllen))))
;;; shell, hunkshell (cont)
;;; Define-accesses(l 1), where l is a list of names, calls define-access(l i)
;;; on the ith element of l and returns the list of all results.
(defun define-accesses* (l n)
(cond (l (cons (define-access* (car l) n)
(define-accesses* (cdr l) (1+ n))))))
;;; define-updates is analogous to define-accesses
(defun define-updates* (l n)
(cond (l (cons (define-update* (car l) n)
(define-updates* (cdr l) (1+ n))))))
;;; example of below: define-access(num, 4) would, if shelllen were 4, return
;;; (defun num macro (app) (cons 'cddr (cdr app))), that is it would make num
;;; synonymous with cddr, since selector(4, 4) is cddr.
(defun define-access* (name num)
(list 'defun name 'macro '(app)
(list 'cons (list 'quote (selector* num shelllen)) '(cdr app))))
;;; hunkshell2 is analogous to shell2
(defun hunkshell2* (l)
(prog (shelllen)
(setq shelllen (length (cdr l)))
(return (cons 'progn
(cons (define-halloc* (car l))
(append (define-haccesses* (cdr l) 0)
(define-hupdates* (cdr l) 0)))))))
;;; the following five functions are analogous to their non-hunk counterparts.
(defun define-halloc* (name)
(list 'defun (concat* 'alloc- name) 'macro '(app)
(list 'quote (list 'makhunk shelllen))))
(defun define-haccesses* (l n)
(and l (cons (define-haccess* (car l) n)
(define-haccesses* (cdr l) (1+ n)))))
(defun define-hupdates* (l n)
(and l (cons (define-hupdate* (car l) n)
(define-hupdates* (cdr l) (1+ n)))))
(defun define-haccess* (name num)
(list 'defun name 'macro '(app)
(list 'cons (list 'quote 'cxr) (list 'cons num '(cdr app)))))
(defun define-hupdate* (name num)
(list 'defun (concat* 'x name) 'macro '(app)
(list 'list ''rplacx num '(cadr app) '(caddr app))))
;;; shell, hunkshell (cont)
;;; example of next function: if shelllen is 4, define-update(num, 4) returns
;;; (defun xnum macro (app) (list 'rplacd (list 'cdr (cadr app)) (caddr app)))
;;; since (clobberer 4 4) is rplacd and (selector2 4 4) is cdr.
;;; In general, selector2(n m) returns cxyxr where "xyx" is a string of
;;; a's and d's sufficient to select out of a binary tree with m leaves,
;;; the dotted pair which contains the nth leaf. a special case arises when
;;; it returns "cr", i.e. when the clobbering function should actually
;;; rplacd or rplaca.
(defun define-update* (name num)
(kwote (defun (! (concat* 'x name)) macro (app)
(list '(! (clobberer* num shelllen))
(! (cond ((eq (selector2* num shelllen) 'cr) '(cadr app))
(t (kwote (list '(! (selector2* num shelllen))
(cadr app))))))
(caddr app)))))
;;; consup(n) returns the form which will evaluate to a complete
;;; binary tree with n leaves, with the (unconventional) convention
;;; that the deeper leaves are to the right.
(defun consup* (n)
(cond ((= n 1) nil)
((list 'cons (consup* (// n 2)) (consup* (// (1+ n) 2))))))
;;; selector(i, n) returns the selector function c***r which will
;;; select the ith leaf of a balanced binary tree with n leaves.
(defun selector* (i n)
(concat* 'c (concat* (implode (sel2* i n)) 'r)))
;;; sel2(i, n) return the list of as and ds which correspond to the
;;; list of cars and cdrs necessary to get to the ith leaf of a
;;; balanced binary tree with n leaves.
(defun sel2* (i n)
(cond ((and (= i 1) (= n 1)) nil)
((> i (// n 2))
(append (sel2* (- i (// n 2)) (// (1+ n) 2)) '(d)))
((append (sel2* i (// n 2)) '(a)))))
;;; i am not very proud of this next function. c.f. define-update.
(defun clobberer* (i n)
(cond ((eq 'a (car (sel2* i n))) 'rplaca)
('rplacd)))
;;; if a shell had two components, the obvious code for changing
;;; the first component is (rplaca (cr x) new) -- that is, no as
;;; or ds are necessary to reach the pair whose component is to be
;;; clobberred. define-update takes care of this special case; note
;;; that selector2 may return 'cr.
(defun selector2* (i n)
(implode (cons 'c (append (cdr (sel2* i n)) '(r)))))
;;; listshell is like shell except it stores its fields in a list.
;;; For (listshell foo a b) it generates (make-foo x y), (get-foo-a x),
;;; (get-foo-b x), (set-foo-a x y) and (set-foo-b x y).
(declare (special lname*))
(defun listshell macro (app)
(setq app (listshell2* (cdr app)))
(cond ((memq 'ncomplr (status feature)) (eval app)))
app)
(defun listshell2* (l)
(prog (lname*)
(setq lname* (car l))
(return (cons 'progn
(cons (define-lalloc* (car l))
(cons (define-ltest* (car l))
(append (define-laccesses* (cdr l) 0)
(define-lupdates* (cdr l) 0))))))))
(defun define-lalloc* (name)
(prog (n)
(setq n (list 'quote (concat* '! name)))
(return (list 'defun (concat* 'make- name) 'macro '(app)
(list 'cons (list 'quote 'list)
(list 'cons (list 'quote n)
(list 'cdr 'app )))))))))))))
(defun define-ltest* (name)
(list 'defun (concat* 'is- name) 'macro '(app)
(list 'kwote (list 'and (list 'not (list 'atom (list '! '(cadr app))))
(list 'eq (list 'kwote (concat* '! name))
(list 'car (list '! '(cadr app)))))))))))
(defun define-laccesses* (l n)
(and l (cons (define-laccess* (car l) n)
(define-laccesses* (cdr l) (1+ n)))))
(defun define-laccess* (name num)
(setq num (implode (append '(c a) (lselector* num nil))))
(list 'defun (concat* 'get- (concat* lname* (concat* '- name)))
'macro '(app)
(list 'kwote (list num (list '! '(cadr app))))))
(defun lselector* (n l)
(cond ((= n 0) (append l '(d r)))
((lselector* (1- n) (cons 'd l)))))
(defun define-lupdates* (l n)
(and l (cons (define-lupdate* (car l) n)
(define-lupdates* (cdr l) (1+ n)))))
(defun define-lupdate* (name num)
(setq num (implode (cons 'c (lselector* num nil))))
(list 'defun (concat* 'set- (concat* lname* (concat* '- name)))
'macro '(app)
(list 'kwote (list 'rplaca (list num (list '! '(cadr app)))
(list '! '(caddr app)))))))
;;; Makenumber*
;;; (makenumber* x) makes a fixnum for x which does not use fixnum space.
;;; A big deficiency of LISP is that it is not possible to have a simple
;;; numeric variable which can be assigned to without calls to FXCONS.
;;; For instance, one often uses an array for a stack and uses some numeric
;;; pointer into the stack. But if one defines PUSH by (setq x (1+ x))
;;; or something like that, the compiler will generate calls to FXCONS to
;;; convert (1+ x) into a fixnum cell. Supposedly if the numbers are small,
;;; no list storage is allocated for the new number but that claim seems false.
;;; Anyway, (makenumber* X) allocates a one word cell called X* and defines
;;; three macros for adding 1 to it, subtracting 1 from it, and accessing
;;; its value -- respectively (XPUSH*), (XPOP*) and (XGET*). X* is actually
;;; a one element array.
;;; Since I only use these special fixnums either for mimicking a stack with
;;; an array or for counting calls to functions, the above three primitives
;;; suffice. It is easy to define other functions for arbitrary addition, etc.
;;; To use, (fasload macros fas dsk (lsp dco)), (declare (makenumber* x))
;;; and (declare (array* (fixnum x* 1)).
(defun makenumber* macro (app)
(prog (x xstack y z w)
(setq x (explode (cadr app)))
(setq xstack (implode (append x '(*))))
(setq w (implode (append x '(g e t *))))
(setq w (kwote (defsmac (! w) nil ((! xstack) 0))))
(setq y (implode (append x '(p u s h *))))
(setq y (kwote
(defsmac (! y) nil
(store ((! xstack) 0) (1+ ((! xstack) 0))))))
(setq z (implode (append x '(p o p *))))
(setq z (kwote
(defsmac (! z) nil
(store ((! xstack) 0) (1- ((! xstack) 0))))))
(return (kwote (progn
(array (! xstack) fixnum 1)
(! w) (! y) (! z))))))
;;; caddddr, ...
(defsmac caddddr (x) (car (cddddr x)))
(defsmac cadddddr (x) (cadr (cddddr x)))
(defsmac caddddddr (x) (caddr (cddddr x)))
(defsmac cadddddddr (x) (cadddr (cddddr x)))
(defsmac caddddddddr (x) (car (cddddr (cddddr x))))
(defsmac cadddddddddr (x) (cadr (cddddr (cddddr x))))
(defsmac caddddddddddr (x) (caddr (cddddr (cddddr x))))
(defsmac cadddddddddddr (x) (cadddr (cddddr (cddddr x))))
(defsmac caddddddddddddr (x) (car (cddddr (cddddr (cddddr x)))))
(defsmac cadddddddddddddr (x) (cadr (cddddr (cddddr (cddddr x)))))
(defsmac caddddddddddddddr (x) (caddr (cddddr (cddddr (cddddr x)))))
(defsmac cadddddddddddddddr (x) (cadddr (cddddr (cddddr (cddddr x)))))
(defsmac caddddddddddddddddr (x) (car (cddddr (cddddr (cddddr (cddddr x))))))
(defsmac cadddddddddddddddddr (x) (cadr (cddddr (cddddr (cddddr (cddddr x))))))
(defsmac cdddddr (x) (cdr (cddddr x)))
(defsmac cddddddr (x) (cddr (cddddr x)))
(defsmac cdddddddr (x) (cdddr (cddddr x))))
(defsmac cddddddddr (x) (cddddr (cddddr x))))
(defsmac cdddddddddr (x) (cdr (cddddr (cddddr x))))
(defsmac cddddddddddr (x) (cddr (cddddr (cddddr x))))
(defsmac cdddddddddddr (x) (cdddr (cddddr (cddddr x)))))
(defsmac cddddddddddddr (x) (cddddr (cddddr (cddddr x)))))
(defsmac cdddddddddddddr (x) (cdr (cddddr (cddddr (cddddr x)))))
(defsmac cddddddddddddddr (x) (cddr (cddddr (cddddr (cddddr x)))))
(defsmac cdddddddddddddddr (x) (cdddr (cddddr (cddddr (cddddr x))))))
(defsmac cddddddddddddddddr (x) (cddddr (cddddr (cddddr (cddddr x))))))
(defsmac cdddddddddddddddddr (x) (cdr (cddddr (cddddr (cddddr (cddddr x))))))
;;; subrcallmacro, subrcallfun, subrcallfunr (see also defunl)
;;; The following macro and subrs are for subrcalls in which the available
;;; argument is a list rather than separate arguments. Given variable
;;; f bound to a subr pointer and l bound to a list of arguments,
;;; (subrcallmacro f l) or (subrcallfun f l) will both execute the same as
;;; (subrcall nil f (car l) (cadr l) (caddr l) (cadddr l) (caddddr l)).
;;; Note that l need not have five elements, nor that the subr need expect
;;; five arguments -- five arguments will be sent to the subr (redundant
;;; arguments will be NIL). (This uses maclsp "feature" : cdr(nil) = nil.)
;;; (subrcallmacro ...) and (subrcallfun ...) are equivalent. Subrcallfun
;;; is somewhat faster, and employs tail recursion. (subrcallmacro ...)
;;; however compiles into very fast code and is provided for those distressed
;;; at seeing actual lap code.
;;; (subrcallfunr ...) is like subrfuncall, but it reverse the list as it goes,
;;; is equivalent to (subrcall f (caddddr l) (cadddr l) (caddr l) (cadr l) (car l))
(defun subrcallmacro macro (args)
(kwote (subrcall nil
(! (cadr args))
(car (! (caddr args)))
(car (cdr (! (caddr args))))
(car (cdr (cdr (! (caddr args)))))
(car (cdr (cdr (cdr (! (caddr args))))))
(car (cdr (cdr (cdr (cdr (! (caddr args))))))))))
(lap subrcallfun subr)
(args subrcallfun (nil . 2))
(push p 1)
(hlrz 1 0 2)
(hrrz 2 0 2)
(hrrz 3 0 2)
(hrrz 4 0 3)
(hrrz 5 0 4)
(hlrz 2 0 2)
(hlrz 3 0 3)
(hlrz 4 0 4)
(hlrz 5 0 5)
(pop p t)
(jrst 0 0 t)
(entry subrcallfunr subr)
(args subrcallfunr (nil . 2))
(push p 1)
(hlrz 5 0 2)
(hrrz 4 0 2)
(hrrz 3 0 4)
(hrrz 2 0 3)
(hrrz 1 0 2)
(hlrz 4 0 4)
(hlrz 3 0 3)
(hlrz 2 0 2)
(hlrz 1 0 1)
(pop p t)
(jrst 0 0 t)
nil
;;; defunl
;;; The following macro DEFUNL is for functions called with a list as their
;;; one argument but which would rather give names to parts of that list.
;;; As an example of its use, (defunl f (a nil b nil c) <mumble>) expands
;;; to something like
;;;
;;; (defun f (l)
;;; (prog (a b c)
;;; (setq a (car l))
;;; (setq b (caddr l))
;;; (setq c (car (cddddr l)))
;;; (return (progn <mumble>))))
;;;
;;; Note that NIL means that the argument is ignorable.
(setq defunlcodelist '((car *l*) (cadr *l*) (caddr *l*) (cadddr *l*)
(car (cddddr *l*))
(cadr (cddddr *l*))
(caddr (cddddr *l*))
(cadddr (cddddr *l*))
(car (cddddr (cddddr *l*)))
(cadr (cddddr (cddddr *l*)))
(caddr (cddddr (cddddr *l*)))
(cadddr (cddddr (cddddr *l*)))))
(defun defunl macro (l)
(cond ((null (caddr l))
(cons 'defun (cons (cadr l) (cons nil (cdddr l)))))
(t (cons 'defun
(cons (cadr l)
(cons '(*l*)
(list (nconc
(cons 'prog
(defunl1 (caddr l) nil nil
defunlcodelist))
(list (list 'return
(cons 'progn (cdddr l))))))))))))
(defun defunl1 (l args body code)
(cond ((null l) (cons args body))
((null (car l)) (defunl1 (cdr l) args body (cdr code)))
(t (defunl1 (cdr l)
(cons (car l) args)
(cons (list 'setq (car l) (car code)) body)
(cdr code)))))
;;; defuna
;;; The following macro defuna is for functions called with a pointer on the
;;; stack liststack* as
;;; one argument but which would rather give names to elements of thet array.
;;; As an example of its use, (defuna f (a nil b nil c) <mumble>) expands
;;; to something like
;;;
;;; (defun f (l)
;;; (prog (a b c)
;;; (setq a (liststack* (- l 4.)))
;;; (setq b (liststack* (- l 2.)))
;;; (setq c (liststack* l))
;;; (return (progn <mumble>))))
;;;
;;; Note that NIL means that the argument is ignorable.
(defun defuna macro (l)
(cond ((null (caddr l))
(cons 'defun (cons (cadr l) (cons nil (cdddr l)))))
(t (cons 'defun
(cons (cadr l)
(cons '(*l*)
(list (nconc
(cons 'prog
(defuna1 (caddr l) nil nil))
(list (list 'return
(cons 'progn (cdddr l))))))))))))
(defun defuna1 (l args body)
(cond ((null l) (cons args body))
((null (car l)) (defuna1 (cdr l) args body))
(t (defuna1 (cdr l)
(cons (car l) args)
(cons (list 'setq (car l)
(list 'liststack*
(list '/- '*l* (length (cdr l)))))
body)))))
;;; miscellaneous: mapcone, mapone, mapctwo, tab, princ-tab, princ-terpri
;;; (mapcone (foo x) l) expands into (mapc '(lambda(x) (foo x)) l)
;;; Thus it calls (foo x) on every element x of l.
(defsmac mapcone (f l) (mapc (function (lambda (x) f)) l))
;;; (mapone (foo x) l) expands into (map '(lambda(x) (foo x)) l)
(defsmac mapone (f l) (map (function (lambda (x) f)) l))
;;; (mapctwo (foo x1 x2) l1 l2) calls (foo x1 x2) on every pair of elements
;;; x1 from l1, and x2 from l2. i.e. it does an n-squared mapc.
(defsmac mapctwo (f l1 l2)
(and l2 (mapc (function (lambda (x1) (mapc (function (lambda (x2) f)) l2))) l1)))
;;; (tab) prints a tab.
(defsmac tab () (princ (ascii 9.)))
;;; (princ-tab x) princ's x and then tabs.
(defsmac princ-tab (x) (princ x) (tab))
;;; (princ-terpri x) princ's x and then adds a carriage return-linefeed.
(defsmac princ-terpri (x) (princ x) (terpri))
;;; (echoterpri) prints a (terpri) on any open file.
;;; It is useful for echoing to backup files carriage-returns typed at terminals.
(DEFSMAC ECHOTERPRI ()
(COND (↑Q (TERPRI)) (↑R ((LAMBDA (↑W) (TERPRI)) T))))
(DEFSMAC PRINC-START (X) (ECHOTERPRI) (PRINC X))
(DEFSMAC PRINC-START-TERPRI (X) (ECHOTERPRI) (PRINC-TERPRI X))
;;; RESCAN, RESCANCOMMAND
;;; RESCAN backs up your terminal's input buffer to the beginning of
;;; the last monitor command typed in.
;;; CAUTION: Because of a bug in the maclsp reader, carriage returns may appear
;;; either as octal 015 (SAIL) or 315 (teletype ASCII, e.g.) Similarly for LF.
(LAP RESCAN SUBR)
(ARGS RESCAN (NIL . 0))
(051←33 10 0) ;RESCAN
(MOVE 1 (% 0 0 'NIL))
(POPJ P)
NIL
;;; RESCANCOMMANd rescans the command line just typed in for parameters.
;;; If the first symbol typed in is an R, it skips ahead to the first
;;; semi-colon, otherwise to the first space. Thus if given R FOO;BAR
;;; it positions the input cursor under BAR; if given FOO BAR it does the
;;; same thing. If a carriage return, form feed or line feed is encountered
;;; during the scan, NIL is returned. Otherwise, after positioning the cursor
;;; after the semi-colon or space, T is returned.
(defun rescancommand ()
(prog (x)
(rescan)
(setq x (tyi))
(or (= x 122) (= x 162) (go b)) ; first character is an R or r
a (setq x (tyi))
(cond ((= x 073) (return (not (member (tyipeek) '(012 014 015 312 315)))))
((member x '(012 014 015 312 315)) (return nil))
(t (go a)))
b (setq x (tyi))
(cond ((member x '(012 014 015 312 315)) (return nil))
((= x 040) (go c))
(t (go b)))
c
(setq x (tyipeek))
(cond ((member x '(012 014 015 312 315)) (return nil))
((= x 040) (tyi) (go c))
(t (return t)))))
;;; RESCAN1 backs up your terminal's input buffer to the beginning of
;;; the last monitor command typed in. Then flushes command line until
;;; after first semi-colon. Returns NIL if no semi-colon read, T otherwise.
(LAP RESCAN1 SUBR)
(ARGS RESCAN1 (NIL . 0))
(051←33 10 0) ;RESCAN
RESC1
(051←33 5 1) ;INCHSL 1
(JRST 0 RETNIL)
(CAIE 1 73) ;CHECK FOR ";"
(JRST 0 RESC1)
(MOVE 1 (% 0 0 'T))
(POPJ P)
RETNIL
(MOVE 1 (% 0 0 'NIL))
(POPJ P)
NIL
;;; RESCAN2 rescans the buffer, flushes through till gets a ";"
;;; If none returns NIL; otherwise scans until finds a charater which
;;; is not ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789.,[]
;;; and returns a list (FILE-HAK <ascii>...).
;;;
(LAP RESCAN2 SUBR)
(ARGS RESCAN2 (NIL . 0))
(051←33 10 0) ;RESCAN
RESC1
(051←33 5 1) ;INCHSL 1
(JRST 0 RETNIL)
(CAIE 1 73) ;CHECK FOR ";"
(JRST 0 RESC1)
(MOVE 2 (% 0 0 'NIL))
MORCHR
(051←33 5 1) ;INCHSL 1
(JRST 0 RET)
(CAIN 1 54) ;.
(JRST 0 GOTCHR)
(CAIN 1 56) ;,
(JRST 0 GOTCHR)
(CAIN 1 133) ;[
(JRST 0 GOTCHR)
(CAIN 1 135) ;]
(JRST 0 GOTCHR)
(CAIG 1 57) ;0 or bigger
(JRST 0 RET)
(CAIG 1 71) ;0123456789
(JRST 0 GOTCHR)
(CAIG 1 100) ;A or bigger
(JRST 0 GOTCHR)
(CAIG 1 132) ;ABCDEFGHIJKLMNOPQRSTUVWXYZ
(JRST 0 GOTCHR)
(CAIG 1 140) ;a or bigger
(JRST 0 GOTCHR)
(CAIG 1 172) ;abcdefghijklmnopqrstuvwxyz
(JRST 0 GOTLIL)
RET
(MOVE 1 2)
(CALL 1(FUNCTION NREVERSE))
(MOVE 2 1)
(MOVE 1 (% 0 0 'FILE-HAK))
(JSP T %CONS)
(POPJ P)
GOTLIL
(SUBI 1 40)
GOTCHR
(HRRE TT 1)
(JSP T FXCONS)
(JSP T %CONS)
(MOVE 2 1)
(JRST 0 MORCHR)
RETNIL
(MOVE 1 (% 0 0 'NIL))
(POPJ P)
NIL
;;; Returns information on terminal attched to the job.
;;; gets the physical name of the terminal attached to the job.
;;; returns the three digits as a fixnum
(LAP TTYNAM SUBR)
(ARGS TTYNAM (NIL . 0))
(HRROI 1 (% 017←33 0 TT))
(047←33 1 400121) ;TTYSET uuo
(JSP T FXCONS)
(POPJ P)
NIL
;;; gets the physical characteristics of the attached terminal
(LAP TERMINAL-ID SUBR)
(ARGS TERMINAL-ID (NIL . 0))
(HRROI TT -1)
(051←33 6 TT) ;GETLIN uuo
(MOVE 1 (% 0 0 'III))
(JUMPL TT RET)
(LSH TT 3)
(MOVE 1 (% 0 0 'DM))
(JUMPL TT RET)
(LSH TT 1)
(MOVE 1 (% 0 0 'DD))
(JUMPL TT RET)
(MOVE 1 (% 0 0 'NIL))
RET
(POPJ P)
NIL